home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / disp-table.el.z / disp-table.el
Encoding:
Text File  |  1998-05-21  |  6.3 KB  |  207 lines
  1. ;;; disp-table.el --- functions for dealing with char tables.
  2.  
  3. ;; Copyright (C) 1987, 1994 Free Software Foundation, Inc.
  4. ;; Copyright (C) 1995 Sun Microsystems.
  5.  
  6. ;; Author: Howard Gayle
  7. ;; Maintainer: XEmacs Development Team
  8. ;; Keywords: i18n
  9.  
  10. ;; This file is part of XEmacs.
  11.  
  12. ;; XEmacs is free software; you can redistribute it and/or modify it
  13. ;; under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; XEmacs is distributed in the hope that it will be useful, but
  18. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20. ;; General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  24. ;; Free Software Foundation, 59 Temple Place - Suite 330,
  25. ;; Boston, MA 02111-1307, USA.
  26.  
  27. ;;; Synched up with: Not synched with FSF.
  28.  
  29. ;;; #### Need lots of work.  make-display-table depends on a value
  30. ;;; that is a define in the C code.  Maybe we should just move the
  31. ;;; function into C.
  32.  
  33. ;;; #### display-tables-as-vectors is really evil and a big pain in
  34. ;;; the ass.
  35.  
  36. ;;; Rewritten for XEmacs July 1995, Ben Wing.
  37.  
  38.  
  39. ;;; Code:
  40.  
  41. (defun describe-display-table (dt)
  42.   "Describe the display table DT in a help buffer."
  43.   (with-displaying-help-buffer
  44.    (lambda ()
  45.      (princ "\nCharacter display glyph sequences:\n")
  46.      (save-excursion
  47.        (let ((vector (make-vector 256 nil))
  48.              (i 0))
  49.          (while (< i 256)
  50.            (aset vector i (aref dt i))
  51.            (incf i))
  52.      ;; FSF calls `describe-vector' here, but it is so incredibly
  53.      ;; lame a function for that name that I cannot bring myself
  54.      ;; to porting it.  Here is what `describe-vector' does:
  55.      (terpri)
  56.      (let ((old (aref vector 0))
  57.            (oldpos 0)
  58.            (i 1)
  59.            str)
  60.        (while (<= i 256)
  61.          (when (or (= i 256)
  62.                (not (equal old (aref vector i))))
  63.            (if (eq oldpos (1- i))
  64.            (princ (format "%s\t\t%s\n"
  65.                   (single-key-description (int-char oldpos))
  66.                   old))
  67.          (setq str (format "%s - %s"
  68.                    (single-key-description (int-char oldpos))
  69.                    (single-key-description (int-char (1- i)))))
  70.          (princ str)
  71.          (princ (make-string (max (- 2 (/ (length str)
  72.                           tab-width)) 1) ?\t))
  73.          (princ old)
  74.          (terpri))
  75.            (or (= i 256)
  76.            (setq old (aref vector i)
  77.              oldpos i)))
  78.          (incf i))))))))
  79.  
  80. ;;;###autoload
  81. (defun describe-current-display-table (&optional domain)
  82.   "Describe the display table in use in the selected window and buffer."
  83.   (interactive)
  84.   (or domain (setq domain (selected-window)))
  85.   (let ((disptab (specifier-instance current-display-table domain)))
  86.     (if disptab
  87.     (describe-display-table disptab)
  88.       (message "No display table"))))
  89.  
  90. ;;;###autoload
  91. (defun make-display-table ()
  92.   "Return a new, empty display table."
  93.   (make-vector 256 nil))
  94.  
  95. ;; #### we need a generic frob-specifier function.
  96. ;; #### this also needs to be redone like frob-face-property.
  97.  
  98. ;; Let me say one more time how much dynamic scoping sucks.
  99.  
  100. (defun frob-display-table (fdt-function fdt-locale)
  101.   (or fdt-locale (setq fdt-locale 'global))
  102.   (or (specifier-spec-list current-display-table fdt-locale)
  103.       (add-spec-to-specifier current-display-table (make-display-table)
  104.                  fdt-locale))
  105.   (add-spec-list-to-specifier
  106.    current-display-table
  107.    (list (cons fdt-locale
  108.            (mapcar
  109.         (lambda (fdt-x)
  110.                   (funcall fdt-function (cdr fdt-x))
  111.                   fdt-x)
  112.         (cdar (specifier-spec-list current-display-table
  113.                        fdt-locale)))))))
  114.  
  115. (defun standard-display-8bit-1 (dt l h)
  116.   (while (<= l h)
  117.     (aset dt l (char-to-string l))
  118.     (setq l (1+ l))))
  119.  
  120. ;;;###autoload
  121. (defun standard-display-8bit (l h &optional locale)
  122.   "Display characters in the range L to H literally."
  123.   (frob-display-table
  124.    (lambda (x)
  125.      (standard-display-8bit-1 x l h))
  126.    locale))
  127.  
  128. (defun standard-display-default-1 (dt l h)
  129.   (while (<= l h)
  130.     (aset dt l nil)
  131.     (setq l (1+ l))))
  132.  
  133. ;;;###autoload
  134. (defun standard-display-default (l h &optional locale)
  135.   "Display characters in the range L to H using the default notation."
  136.   (frob-display-table
  137.    (lambda (x)
  138.      (standard-display-default-1 x l h))
  139.    locale))
  140.  
  141. ;;;###autoload
  142. (defun standard-display-ascii (c s &optional locale)
  143.   "Display character C using printable string S."
  144.   (frob-display-table
  145.    (lambda (x)
  146.      (aset x c s))
  147.    locale))
  148.  
  149.  
  150. ;;; #### should frob in a 'tty locale.
  151.  
  152. ;;;###autoload
  153. (defun standard-display-g1 (c sc &optional locale)
  154.   "Display character C as character SC in the g1 character set.
  155. This function assumes that your terminal uses the SO/SI characters;
  156. it is meaningless for an X frame."
  157.   (frob-display-table
  158.    (lambda (x)
  159.      (aset x c (concat "\016" (char-to-string sc) "\017")))
  160.    locale))
  161.  
  162.  
  163. ;;; #### should frob in a 'tty locale.
  164.  
  165. ;;;###autoload
  166. (defun standard-display-graphic (c gc &optional locale)
  167.   "Display character C as character GC in graphics character set.
  168. This function assumes VT100-compatible escapes; it is meaningless for an
  169. X frame."
  170.   (frob-display-table
  171.    (lambda (x)
  172.      (aset x c (concat "\e(0" (char-to-string gc) "\e(B")))
  173.    locale))
  174.  
  175. ;;; #### should frob in a 'tty locale.
  176. ;;; #### the FSF equivalent of this makes this character be displayed
  177. ;;; in the 'underline face.  There's no current way to do this with
  178. ;;; XEmacs display tables.
  179.  
  180. ;;;###autoload
  181. (defun standard-display-underline (c uc &optional locale)
  182.   "Display character C as character UC plus underlining."
  183.   (frob-display-table
  184.    (lambda (x)
  185.      (aset x c (concat "\e[4m" (char-to-string uc) "\e[m")))
  186.    locale))
  187.  
  188. ;;;###autoload
  189. (defun standard-display-european (arg &optional locale)
  190.   "Toggle display of European characters encoded with ISO 8859.
  191. When enabled, characters in the range of 160 to 255 display not
  192. as octal escapes, but as accented characters.
  193. With prefix argument, enable European character display iff arg is positive."
  194.   (interactive "P")
  195.   (frob-display-table
  196.    (lambda (x)
  197.      (if (or (<= (prefix-numeric-value arg) 0)
  198.              (and (null arg)
  199.                   (equal (aref x 160) (char-to-string 160))))
  200.          (standard-display-default-1 x 160 255)
  201.        (standard-display-8bit-1 x 160 255)))
  202.    locale))
  203.  
  204. (provide 'disp-table)
  205.  
  206. ;;; disp-table.el ends here
  207.